Pascal Super Library/Pascal Super Library (CW International)(1997).bin/COMPILER/VP10B003/VPC.ZIP/EXAMPLES/VPPATCH/VPPATCH.PAS

Pascal/Delphi Source File | 1995-06-22 | 9KB | 350 lines

{█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
{█                                                       █}
{█      Virtual Pascal Examples  Version 1.0             █}
{█      VPPATCH command line utility.                    █}
{█      ─────────────────────────────────────────────────█}
{█      Copyright (C) 1995 B&M&T Corporation             █}
{█      ─────────────────────────────────────────────────█}
{█      Written by Vitaly Miryanov                       █}
{█                                                       █}
{▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}

{ This command line utility is used to produce            }
{ Turbo Vision patch for Virtual Pascal.                  }

{$I-,V-}

program VpPatch;

uses Dos, Use32;

var
  FilesOpened,StartQuote: Boolean;
  PatchLineIndex,PatchLineNo,SrcLineNo,DestLineNo: Integer;
  SrcLoNo,SrcHiNo: Integer;
  DestLoNo,DestHiNo: Integer;
  PatchFile, SrcFile, DestFile: Text;
  PatchLine,TextWord: String;
  DestFileName: PathStr;
  PatchFileBuf,SrcFileBuf,DestFileBuf: array[1..4*1096] of Byte;

{ Displays command line prompt and terminates }

procedure DisplayPrompt;
begin
  WriteLn('Syntax: VPPATCH PatchFile SrcDir DestDir');
  WriteLn('PatchFile  = Patch file name');
  WriteLn('SrcDir     = Directory with original sources');
  WriteLn('DestDir    = Destination directory to hold patched sources');
  Halt(1);
end;

{ Displays error message and terminates }

procedure Error(const ErrStr: String);
begin
  WriteLn('**Error**  ', ErrStr);
  Halt(2);
end;

{ Displays error message with offended patch file line number }

procedure ErrorLineNo(const ErrStr: String);
begin
  WriteLn('**Error** ', ParamStr(1), '(', PatchLineNo, ') ', ErrStr);
end;

{ Reports bad patch file error and terminates }

procedure BadPatchFile;
begin
  ErrorLineNo('Syntax error');
  Halt(2);
end;

{ Expands tabs to spaces and returns converted string }

procedure ExpandTabs(var S: String);
var
  I,J,K,N: Integer;
  C: Char;
  Dest: String;
begin
  J := 1;
  for I := 1 to Length(S) do
  begin
    C := S[I];
    if C <> #9 then N := 1
   else
    begin
      N := 8 - ((J+7) and $7);
      C := ' ';
    end;
    for K := 1 to N do
    if J <= 255 then
    begin
      Dest[J] := C;
      Inc(J);
    end;
  end;
  Dest[0] := Chr(J-1);
  S := Dest;
end;

{ Converts string to upper case }

function UpStr(const S: String): String;
var
  I: Integer;
  S1: String;
begin
  for I := 1 to Length(S) do S1[I] := UpCase(S[I]);
  S1[0] := S[0];
  UpStr := S1;
end;

{ Reads source file line and checks for errors }

procedure ReadSrcLine(var S: String);
begin
  ReadLn(SrcFile, S);
  Inc(SrcLineNo);
  if IOResult <> 0 then Error('Error reading source file');
end;

{ Writes line to the destination file and checks for errors }

procedure WriteDestLine(var S: String);
begin
  WriteLn(DestFile, S);
  Inc(DestLineNo);
  if IOResult <> 0 then Error('Error writing to destination file');
end;

{ Reads unused source lines }

procedure PurgeSrcLines;
var
  S: String;
begin
  while SrcLineNo < SrcHiNo do ReadSrcLine(S);
end;

{ Closes source and destination files }

procedure CloseFiles;
var
  S: String;
begin
  if FilesOpened then
  begin
    PurgeSrcLines;
    while not EOF(SrcFile) do
    begin
      ReadSrcLine(S);
      WriteDestLine(S);
    end;
    Close(SrcFile); InOutRes := 0;
    Close(DestFile); InOutRes := 0;
    FilesOpened := False;
  end;
end;

{ Gets word from patch file line }

procedure GetWord;
begin
  TextWord := '';
  { Skip blanks }
  while (PatchLineIndex <= Length(PatchLine)) and
    (PatchLine[PatchLineIndex] in [#9,' ']) do Inc(PatchLineIndex);
  { Extract word }
  while (PatchLineIndex <= Length(PatchLine)) and
    not (PatchLine[PatchLineIndex] in [#9,' ']) do
  begin
    Inc(TextWord[0]);
    TextWord[Length(TextWord)] := PatchLine[PatchLineIndex];
    Inc(PatchLineIndex);
  end;
end;

{ Gets integer number from patch file line }

function GetNumber: Integer;
var
  Number,Code: Integer;
begin
  TextWord := '';
  Number := 0;
  { Extract number }
  while (PatchLineIndex <= Length(PatchLine)) and
    (PatchLine[PatchLineIndex] in ['0'..'9']) do
  begin
    Inc(TextWord[0]);
    TextWord[Length(TextWord)] := PatchLine[PatchLineIndex];
    Inc(PatchLineIndex);
  end;
  Val(TextWord, Number, Code);
  if Code <> 0 then BadPatchFile;
  GetNumber := Number;
end;

{ Returns true if next character is comma }

function CheckComma: Boolean;
begin
  CheckComma := False;
  if (PatchLineIndex <= Length(PatchLine)) and
    (PatchLine[PatchLineIndex] = ',') then
  begin
    CheckComma := True;
    Inc(PatchLineIndex);
  end;
end;

{ Get command letter }

function GetCommand: Char;
begin
  GetCommand := #0;
  if (PatchLineIndex <= Length(PatchLine)) then
  begin
    GetCommand := PatchLine[PatchLineIndex];
    Inc(PatchLineIndex);
  end;
end;

{ Processes patch file line }

procedure ProcessPatchLine;
var
  Dir: DirStr;
  Name: NameStr;
  Ext: ExtStr;
  FileName: PathStr;
  S,S1: String;
begin
  case PatchLine[1] of
    'C':
    { New files are selected, open source file and create destination one }
    { Example: 'Comparing BP7\APP.PAS and VP\APP.PAS'                     }
    begin
      GetWord;
      if TextWord <> 'Comparing' then BadPatchFile;
      CloseFiles;
      GetWord;                            { Source file name }
      FSplit(TextWord, Dir, Name, Ext);
      FileName := ParamStr(2);            { Source directory }
      if FileName[Length(FileName)] <> '\' then FileName := FileName + '\';
      FileName := FileName + Name + Ext;
      Assign(SrcFile, FileName);
      SetTextBuf(SrcFile, SrcFileBuf);
      Reset(SrcFile);
      if IOResult <> 0 then Error('Could not open source file ' + FileName);
      WriteLn('Processing ', UpStr(FileName));
      FileName := ParamStr(3);            { Destination directory }
      if FileName[Length(FileName)] <> '\' then FileName := FileName + '\';
      FileName := FileName + Name + Ext;
      Assign(DestFile, FileName);
      SetTextBuf(DestFile, DestFileBuf);
      Rewrite(DestFile);
      if IOResult <> 0 then Error('Could not create destination file ' + FileName);
      FilesOpened := True;
      SrcLineNo := 0; SrcLoNo := 0; SrcHiNo := 0;
      DestLineNo := 0; DestLoNo := 0; DestHiNo := 0;
    end;

    '0'..'9':
      { Command in one of the three valid forms:       }
      { 1)   n1 a n3,n4                                }
      { 2)   n1,n2 d n3                                }
      { 3)   n1,n2 c n3,n4                             }
      { Identical pairs where n1 = n2 or n3 = n4 are   }
      { abbreviated as a single number.                }
      { Examples: '13c13'                              }
      {           '16a17,18'                           }
      {           '18d19'                              }
      begin
        PurgeSrcLines;
        SrcLoNo := GetNumber; SrcHiNo := SrcLoNo;
        if CheckComma then SrcHiNo := GetNumber;
        if not (GetCommand in ['a','d','c']) then BadPatchFile;
        DestLoNo := GetNumber; DestHiNo := DestLoNo;
        if CheckComma then DestHiNo := GetNumber;
        StartQuote := True;
      end;

    '<':
      { Source file is quoted }
      begin
        S := Copy(PatchLine, 3, 255);
        if StartQuote then
          while SrcLineNo < SrcLoNo-1 do
          begin
            ReadSrcLine(S1);
            WriteDestLine(S1);
          end;
        ReadSrcLine(S1);
        Inc(SrcLoNo);
        ExpandTabs(S1);
        if UpStr(S) <> UpStr(S1) then
        begin
          ErrorLineNo('Invalid source file');
          WriteLn('File ', TextRec(SrcFile).Name, '(', SrcLineNo, '):');
          WriteLn('Expected: ''',S , '''');
          WriteLn('Got:      ''',S1, '''');
          Halt(2);
        end;
        StartQuote := False;
      end;

    '>':
      { Destination file is quoted }
      begin
        S := Copy(PatchLine, 3, 255);
        if StartQuote then
          while SrcLineNo < SrcLoNo do
          begin
            ReadSrcLine(S1);
            WriteDestLine(S1);
          end;
        if DestLoNo-1 <> DestLineNo then BadPatchFile;
        WriteDestLine(S);
        Inc(DestLoNo);
        StartQuote := False;
      end;

    else BadPatchFile;
  end;
end;

{ Main patch routine }

procedure DoPatch;
begin
  FilesOpened := False;
  PatchLineNo := 0;
  Assign(PatchFile, ParamStr(1));
  SetTextBuf(PatchFile, PatchFileBuf);
  Reset(PatchFile);
  if IOResult <> 0 then Error('Could not open patch file ' + ParamStr(1));
  while not EOF(PatchFile) do
  begin
    ReadLn(PatchFile, PatchLine);
    if IOResult <> 0 then Error('Error reading patch file');
    PatchLineIndex := 1;
    Inc(PatchLineNo);
    if PatchLine <> '' then ProcessPatchLine;
  end;
  Close(PatchFile); InOutRes := 0;
  CloseFiles;
end;

begin
  WriteLn('Virtual Pascal Patch  Version 1.0 Copyright (C) 1995 B&M&T Corporation');
  if ParamCount <> 3 then DisplayPrompt;
  if FExpand(ParamStr(2)) = FExpand(ParamStr(3)) then
    Error('Source and destination paths are the same');
  DoPatch;
end.